home *** CD-ROM | disk | FTP | other *** search
/ PC Plus SuperCD (UK) 1999 January / PC Plus Super CD No55a (PCP-147A-1-99) (Disc 1) (1998).iso / linux / developers / visualtcl / windows / vtcl / demo / draw.tcl < prev    next >
Encoding:
Text File  |  1998-02-01  |  10.5 KB  |  311 lines
  1. #############################################################################
  2. # Visual Tcl v1.11 Project
  3. #
  4.  
  5. #################################
  6. # GLOBAL VARIABLES
  7. #
  8. global img; 
  9. global widget; 
  10.     set widget(CANVAS) {.top28.fra29.can30}
  11.     set widget(rev,.01.02) {CANVAS}
  12.     set widget(rev,.tclet.01) {CANVAS}
  13.     set widget(rev,.top28.fra29.can30) {CANVAS}
  14.  
  15. #################################
  16. # USER DEFINED PROCEDURES
  17. #
  18. proc init {argc argv} {
  19. global vTcl tcl_platform tcl_version tk_strictMotif img
  20. catch {package require unsafe}
  21. set tk_strictMotif 1
  22.  
  23. global tool; 
  24. global x; 
  25. global y; 
  26. global img; 
  27. set img(line) {
  28.     R0lGODdhKAAoAPUAAAAAADj4MEDsMEjkMFBQ+FDcMFjQMGDIMGjAMHB0cHC4MHikOHisMIB8
  29.     eICAgICcOIiQOJCIOJiAOKB4OKC0yKDEyKgoGKhsOLBkOLhcOLi4uMBQOMDAwMhIOMjEwNBA
  30.     ONg4ONh8eOAsOOC4gOgkOPAcOPC4OPgUQPiIOPj8+AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
  31.     AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACwAAAAAKAAoAAAG
  32.     f8CUcEgsGo/IpHLJbDqf0Kj0CKhOo9Us4NrUerlJrxhc1KbM5yw5vRV+2e2r2t22DtFYO31f
  33.     jj/nd3F6XICBhmCFh2xrVH5pjEaDj5BEkpOUl4qUlplrnJ1kn4mIjpWlhKd8jJ+qoamtmJGs
  34.     sbOYtbavtLm4sb2+v8DBwsPEv0EAOw==
  35. }
  36. set img(rect) {
  37.     R0lGODdhKAAoAPUAAAAAADj4MEDsMEjkMFBQ+FDcMFjQMGDIMGjAMHB0cHC4MHikOHisMIB8
  38.     eICAgICcOIiQOJCIOJiAOKB4OKC0yKDEyKgoGKhsOLBkOLhcOLi4uMBQOMDAwMhIOMjEwNBA
  39.     ONg4ONh8eOAsOOC4gOgkOPAcOPC4OPgUQPiIOPj8+AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
  40.     AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACwAAAAAKAAoAAAG
  41.     XsCUcEgsGo/IpHLJbDqf0Kh0Sq1ar9isdsvtOgHgsHhMBkfLaPQZMDVD3eu4FP5lz+1Peh5f
  42.     b/Oben1vf4J7fnKIhYOJhot3jIqAaZNha5STXpmam5ydnp+goaKjVkEAOw==
  43. }
  44. set img(oval) {
  45.     R0lGODdhKAAoAPUAAAAAADj4MEDsMEjkMFBQ+FDcMFjQMGDIMGjAMHB0cHC4MHikOHisMIB8
  46.     eICAgICcOIiQOJCIOJiAOKB4OKC0yKDEyKgoGKhsOLBkOLhcOLi4uMBQOMDAwMhIOMjEwNBA
  47.     ONg4ONh8eOAsOOC4gOgkOPAcOPC4OPgUQPiIOPj8+AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
  48.     AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACwAAAAAKAAoAAAG
  49.     YsCUcEgsGo/IpHLJbDqf0Kh0Sq1ar9isdstVAr5gQDcFPpax32a6Koa2pW83nC23xpf3uTqb
  50.     N/P3aIBXfX52T4SHdVOISYyNVI5GkV6Ta4OWRGdcYZpjnp+goaKjpKWmp11BADs=
  51. }
  52. set img(free) {
  53.     R0lGODdhKAAoAPcAAAAAALi4uNh8eOC4gPC4OPj8+AEUAEAIAMg0E6D4ABT/AAi/ABA1Aa+y
  54.     ABQBAAhAAMQsuKeppxQUFAgICMi04DL39gj//0C/vw4EwMAA9gEA/0AAv1DIbwEytQAIAQBA
  55.     QDjIyKigoBDIEK+gr+AkvPivp/8UFL8ICDEb5v22pwIAFEAACDYEEKgArxQAFAgACGjInrSg
  56.     vQwUAQgIQMFkG4r4AA3/AEC/AIwEDVoAABQAAEAAAADIGACgAAAUAAQIADBw/Nb4pxD/FAy/
  57.     CDA1HNay9xAB/whAv+gETskAkhEAB1DInqigvRQUATgEG6gAAAgAAMjIDTKgAAgUAPyIGPj4
  58.     AP//AL+/AJQ1BLWyqAQBFEBACAnQHACn9wAU/wAIvwgIgKf4khT/Bwi/CEwEyAIAoAAAFAAA
  59.     CMjIgzIyAAgIAEBABRjIEPmgr8TIG7+gAAQUAIAkEKavABQUAAgbGae2AEwEEgIAAGS4KPn4
  60.     9////7+/v701LnmymggBBwhACGwE8MKozwwUEwA4AQD4AAD/AAC/ANgENfkAJ/8AEb8ACLDI
  61.     OA0y9xYI/8jIFTKgjQgUB0AICNTIrPmgzf8UE9gkhPmv/P8U/78Iv7AAOA0A+hYA/wgAv5TI
  62.     v/mggf8UBaAQDayvAAcUAAAgAACpAAAIAAHIhAAy/AAI/wBAvygOhADA/AAB/yhSqAAB+QAA
  63.     /wAAvwCkAAAQAAGvANyMAPn4ANgxAPn9AP8CAL9AAJSahPmp/Nz8JKz4rwf/FLAKGw0AthYA
  64.     ACjsTwAAdgAAZQAAcihudwAAaQAFdAAHZQD5IAD/ZQC/eIQKafwAc/8AdL8AaQCgBABvyAC1
  65.     oAABFABACAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
  66.     AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
  67.     AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACwAAAAAKAAoAAAIngALCBxIsKDBgwgTKlzIsKHD
  68.     hxAjSlQIoOLEiAAEaARw8WHGjR0bVgQZkiGAABk5lqQYoKXKlQkruoQZk0DFlzQNAiDAE2fO
  69.     gTt7/jwY1ObQgkV9Hk16lCDTpkB5GoVa4ClVq02xZpWq9KfWpVxNdvxKdOyAAVPFTgRwtitC
  70.     tyYterwod+5YpHWRlnzJVyfMm3hvwqVKuLDhw4gTNw0IADs=
  71. }
  72.  
  73. if {$tcl_version < 7.7} {
  74.     if {[info exists vTcl(VTCL_HOME)]} {
  75.         set base [file join $vTcl(VTCL_HOME) demo]
  76.     } else {
  77.         set base [pwd]
  78.     }
  79.     image create photo free -file [file join $base images free.gif]
  80.     image create photo line -file [file join $base images line.gif]
  81.     image create photo rect -file [file join $base images rect.gif]
  82.     image create photo oval -file [file join $base images oval.gif]
  83. } else {
  84.     foreach i {free line rect oval} {
  85.         image create photo $i -data $img($i)
  86.     }
  87. }
  88. }
  89.  
  90. init $argc $argv
  91.  
  92.  
  93. proc {button-down} {sx sy} {
  94. global tool x y obj widget
  95.  
  96. switch $tool {
  97.     free -
  98.     line {
  99.         set x $sx
  100.         set y $sy
  101.         set obj [$widget(CANVAS) create line $x $y $x $y]
  102.     }
  103.     rect {
  104.         set x $sx
  105.         set y $sy
  106.         set obj [$widget(CANVAS) create rectangle $x $y $x $y]
  107.     }
  108.     ellipse {
  109.         set x $sx
  110.         set y $sy
  111.         set obj [$widget(CANVAS) create arc $x $y $x $y -start 0 -extent 359 -style arc]
  112.     }
  113. }
  114. }
  115.  
  116. proc {button-motion} {nx ny} {
  117. global tool x y obj widget
  118.  
  119. switch $tool {
  120.     free {
  121.         $widget(CANVAS) create line $x $y $nx $ny
  122.         set x $nx
  123.         set y $ny
  124.     }
  125.     line -
  126.     rect -
  127.     ellipse {
  128.         $widget(CANVAS) coords $obj $x $y $nx $ny
  129.     }
  130. }
  131. }
  132.  
  133. proc {button-release} {nx ny} {
  134. global tool x y
  135.  
  136. switch $tool {
  137. }
  138. }
  139.  
  140. proc {main} {argc argv} {
  141.  
  142. }
  143.  
  144. proc {Window} {args} {
  145. global vTcl
  146.     set cmd [lindex $args 0]
  147.     set name [lindex $args 1]
  148.     set newname [lindex $args 2]
  149.     set rest [lrange $args 3 end]
  150.     if {$name == "" || $cmd == ""} {return}
  151.     if {$newname == ""} {
  152.         set newname $name
  153.     }
  154.     set exists [winfo exists $newname]
  155.     switch $cmd {
  156.         show {
  157.             if {$exists == "1" && $name != "."} {wm deiconify $name; return}
  158.             if {[info procs vTclWindow(pre)$name] != ""} {
  159.                 eval "vTclWindow(pre)$name $newname $rest"
  160.             }
  161.             if {[info procs vTclWindow$name] != ""} {
  162.                 eval "vTclWindow$name $newname $rest"
  163.             }
  164.             if {[info procs vTclWindow(post)$name] != ""} {
  165.                 eval "vTclWindow(post)$name $newname $rest"
  166.             }
  167.         }
  168.         hide    { if $exists {wm withdraw $newname; return} }
  169.         iconify { if $exists {wm iconify $newname; return} }
  170.         destroy { if $exists {destroy $newname; return} }
  171.     }
  172. }
  173.  
  174. #################################
  175. # VTCL GENERATED GUI PROCEDURES
  176. #
  177.  
  178. proc vTclWindow. {base} {
  179.     if {$base == ""} {
  180.         set base .
  181.     }
  182.     ###################
  183.     # CREATING WIDGETS
  184.     ###################
  185.     wm focusmodel $base passive
  186.     wm geometry $base 200x200+0+0
  187.     wm maxsize $base 1137 870
  188.     wm minsize $base 96 1
  189.     wm overrideredirect $base 0
  190.     wm resizable $base 1 1
  191.     wm withdraw $base
  192.     wm title $base "vt.tcl"
  193.     ###################
  194.     # SETTING GEOMETRY
  195.     ###################
  196. }
  197.  
  198. proc vTclWindow.top28 {base} {
  199.     if {$base == ""} {
  200.         set base .top28
  201.     }
  202.     if {[winfo exists $base]} {
  203.         wm deiconify $base; return
  204.     }
  205.     ###################
  206.     # CREATING WIDGETS
  207.     ###################
  208.     toplevel $base -class Toplevel
  209.     wm focusmodel $base passive
  210.     wm geometry $base 503x352+95+172
  211.     wm maxsize $base 1137 870
  212.     wm minsize $base 96 1
  213.     wm overrideredirect $base 0
  214.     wm resizable $base 1 1
  215.     wm deiconify $base
  216.     wm title $base "Drawing Tclet"
  217.     frame $base.fra29 \
  218.         -borderwidth 1 -height 30 -relief raised -width 30 
  219.     canvas $base.fra29.can30 \
  220.         -borderwidth 2 -height 246 -highlightthickness 0 -relief ridge \
  221.         -width 351 
  222.     bind $base.fra29.can30 <B1-Motion> {
  223.         button-motion %x %y
  224.     }
  225.     bind $base.fra29.can30 <Button-1> {
  226.         button-down %x %y
  227.     }
  228.     bind $base.fra29.can30 <ButtonRelease-1> {
  229.         button-release %x %y
  230.     }
  231.     frame $base.fra29.fra31 \
  232.         -borderwidth 1 -height 30 -relief sunken -width 30 
  233.     button $base.fra29.fra31.01 \
  234.         -command {set tool free} \
  235.         -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*-* \
  236.         -highlightthickness 0 -image free -padx 11 -pady 4 -text free 
  237.     button $base.fra29.fra31.02 \
  238.         -command {set tool line} \
  239.         -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*-* \
  240.         -highlightthickness 0 -image line -padx 11 -pady 4 -text line 
  241.     button $base.fra29.fra31.03 \
  242.         -command {set tool rect} \
  243.         -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*-* \
  244.         -highlightthickness 0 -image rect -padx 11 -pady 4 -text rect 
  245.     button $base.fra29.fra31.04 \
  246.         -command {set tool ellipse} \
  247.         -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*-* \
  248.         -highlightthickness 0 -image oval -padx 11 -pady 4 -text ellipse 
  249.     frame $base.fra29.fra32 \
  250.         -borderwidth 2 -height 45 -relief groove -width 45 
  251.     frame $base.fra29.fra32.01 \
  252.         -background #ffffff -borderwidth 1 -height 30 -relief raised \
  253.         -width 30 
  254.     frame $base.fra29.fra32.02 \
  255.         -background #000000 -borderwidth 1 -height 30 -relief raised \
  256.         -width 30 
  257.     label $base.fra29.lab33 \
  258.         -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*-* \
  259.         -text select 
  260.     label $base.fra29.lab34 \
  261.         -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*-* \
  262.         -text {a tool} 
  263.     button $base.fra29.but35 \
  264.         -command exit \
  265.         -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*-* \
  266.         -highlightthickness 0 -padx 9 -pady 3 -text Quit 
  267.     ###################
  268.     # SETTING GEOMETRY
  269.     ###################
  270.     pack $base.fra29 \
  271.         -in .top28 -anchor center -expand 1 -fill both -padx 5 -pady 5 \
  272.         -side top 
  273.     grid columnconf $base.fra29 0 -weight 1
  274.     grid columnconf $base.fra29 1 -minsize 45
  275.     grid rowconf $base.fra29 5 -weight 1
  276.     grid rowconf $base.fra29 1 -minsize 45
  277.     grid $base.fra29.can30 \
  278.         -in .top28.fra29 -column 0 -row 0 -columnspan 1 -rowspan 6 -padx 5 \
  279.         -pady 5 -sticky nesw 
  280.     grid $base.fra29.fra31 \
  281.         -in .top28.fra29 -column 1 -row 0 -columnspan 1 -rowspan 1 -padx 5 \
  282.         -pady 5 -sticky n 
  283.     pack $base.fra29.fra31.01 \
  284.         -in .top28.fra29.fra31 -anchor center -expand 1 -fill both -side top 
  285.     pack $base.fra29.fra31.02 \
  286.         -in .top28.fra29.fra31 -anchor center -expand 1 -fill both -side top 
  287.     pack $base.fra29.fra31.03 \
  288.         -in .top28.fra29.fra31 -anchor center -expand 1 -fill both -side top 
  289.     pack $base.fra29.fra31.04 \
  290.         -in .top28.fra29.fra31 -anchor center -expand 1 -fill both -side top 
  291.     grid $base.fra29.fra32 \
  292.         -in .top28.fra29 -column 1 -row 1 -columnspan 1 -rowspan 1 -padx 5 \
  293.         -pady 5 
  294.     place $base.fra29.fra32.01 \
  295.         -x 15 -y 15 -width 25 -height 25 -anchor nw -bordermode ignore 
  296.     place $base.fra29.fra32.02 \
  297.         -x 5 -y 5 -width 25 -height 25 -anchor nw -bordermode ignore 
  298.     grid $base.fra29.lab33 \
  299.         -in .top28.fra29 -column 1 -row 3 -columnspan 1 -rowspan 1 
  300.     grid $base.fra29.lab34 \
  301.         -in .top28.fra29 -column 1 -row 4 -columnspan 1 -rowspan 1 
  302.     grid $base.fra29.but35 \
  303.         -in .top28.fra29 -column 1 -row 5 -columnspan 1 -rowspan 1 -padx 5 \
  304.         -pady 5 -sticky ns 
  305. }
  306.  
  307. Window show .
  308. Window show .top28
  309.  
  310. main $argc $argv
  311.